home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue56 / Clinic / DCMemo.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2000-01-19  |  2.5 KB  |  106 lines
  1. unit DCMemo;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs, StdCtrls;
  8.  
  9. type
  10.   TDCMemo = class(TMemo)
  11.   private
  12.     FAutoScrollBar: Boolean;
  13.     procedure SetAutoScrollBar(const Value: Boolean);
  14.     function TextHeight(const Msg: String): Integer;
  15.   protected
  16.     procedure Change; override;
  17.     procedure CheckScrollBar; virtual;
  18.   published
  19.     property AutoScrollBar: Boolean
  20.       read FAutoScrollBar write SetAutoScrollBar default False;
  21.   end;
  22.  
  23. procedure Register;
  24.  
  25. implementation
  26.  
  27. procedure Register;
  28. begin
  29.   RegisterComponents('Clinic', [TDCMemo]);
  30. end;
  31.  
  32. { TDCMemo }
  33.  
  34. function TDCMemo.TextHeight(const Msg: String): Integer;
  35. var
  36.   DC: HDC;
  37.   OldFont: HFont;
  38.   Size: TSize;
  39. begin
  40.   { Can't just ask a control for the font height, as Delphi }
  41.   { caches the font and doesn't select it into the device }
  42.   { context until some drawing is required. }
  43.   { The memo may have a different font to its form and under }
  44.   { those circumstances, you could get bad results. }
  45.  
  46.   { Access control's device context }
  47.   DC := GetDC(Handle);
  48.   try
  49.     { Ensure font is selected into DC (saving old font) }
  50.     OldFont := SelectObject(DC, Font.Handle);
  51.     try
  52.       { Find text height }
  53.     {$ifdef Win32}
  54.       Win32Check(GetTextExtentPoint32(DC, PChar(Msg), 1, Size));
  55.     {$else}
  56.       GetTextExtentPoint(DC, @(Msg[1]), 1, Size);
  57.     {$endif}
  58.       Result := Size.cy
  59.     finally
  60.       { Put old font back into memo }
  61.       SelectObject(DC, OldFont)
  62.     end;
  63.   finally
  64.     { Let the DC go }
  65.     ReleaseDC(Handle, DC)
  66.   end;
  67. end;
  68.  
  69. procedure TDCMemo.Change;
  70. begin
  71.   inherited Change;
  72.   CheckScrollBar
  73. end;
  74.  
  75. procedure TDCMemo.SetAutoScrollBar(const Value: Boolean);
  76. begin
  77.   if FAutoScrollBar <> Value then
  78.   begin
  79.     FAutoScrollBar := Value;
  80.     CheckScrollBar;
  81.   end
  82. end;
  83.  
  84. procedure TDCMemo.CheckScrollBar;
  85. var
  86.   MemoNumLines: Integer;
  87.   OldSelStart, OldSelLength: Integer;
  88. begin
  89.   { Only proceed if the memo has a parent, and so is on-screen }
  90.   if not Assigned(Parent) then
  91.     Exit;
  92.   MemoNumLines := ClientHeight div TextHeight('X');
  93.   { Record where we were }
  94.   OldSelStart := SelStart;
  95.   OldSelLength := SelLength;
  96.   if Perform(EM_GETLINECOUNT, 0, 0) > MemoNumLines then
  97.     ScrollBars := ssVertical
  98.   else
  99.     ScrollBars := ssNone;
  100.   { Go back to old position after memo control (possibly) recreated }
  101.   SelStart := OldSelStart;
  102.   SelLength := OldSelLength;
  103. end;
  104.  
  105. end.
  106.